home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Environments / Clean 1.2.4 / IO Examples / Turing / Turing.icl < prev    next >
Encoding:
Text File  |  1997-04-25  |  11.8 KB  |  340 lines  |  [TEXT/3PRM]
  1. module Turing
  2.  
  3. /*    A Turing machine interpreter and programming environment.
  4.     This program requires the 0.8 I/O library.
  5.     Run the program using the "No Console" option (Application options).
  6. */
  7.  
  8. import StdInt, StdString, StdBool, StdFile, StdTuple
  9. import deltaSystem, deltaFileSelect, deltaEventIO, deltaIOSystem, deltaMenu, deltaWindow, deltaTimer
  10. import tm, showtm, tmdialog, tmfile, Help
  11.  
  12. WdCorner    :== (0,  0)
  13. TWdCorner    :== (100,210)
  14. WindowMin    :== (50, 50)
  15. WindowInit    :== (500,265)
  16. TapeWdMin    :== (50, 50)
  17. TapeWdInit    :== (400,60)
  18. WindowPSize    :== ((0,0), (MaxX, 265))
  19. TapeWdPSize    :== ((0,0), (MaxX, 92))
  20.  
  21. Horbar        :== ScrollBar (Thumb 0) (Scroll 24)
  22. Verbar        :== ScrollBar (Thumb 0) (Scroll 8)
  23.  
  24. Speed1        :== TicksPerSecond / 3
  25. Speed2        :== TicksPerSecond / 6
  26. Speed3        :== TicksPerSecond / 12
  27. Speed4        :== TicksPerSecond / 20
  28. Speed5        :== 0
  29.  
  30. Start :: *World -> *World
  31. Start world
  32. #    (events,world)        = OpenEvents world
  33.     (files, world)        = openfiles  world
  34.     (aboutdialog,files)    = MakeAboutDialog "Turing" HelpFile files Help
  35.     progstate0            = NewTuring files
  36.     about                = DialogSystem [aboutdialog]
  37.     (progstateN,events)    = StartIO [about, menu, window, timer] progstate0 [] events
  38.     files                = progstateN.disk
  39.     world                = closefiles  files  world
  40.     world                = CloseEvents events world
  41. =    world
  42. where
  43.     menu                = MenuSystem [file, machine]
  44.     file                = PullDownMenu FileMenuId "File" Able
  45.                             [    MenuItem NewItemId  "New"        (Key 'N') Able   DoNew
  46.                             ,    MenuItem OpenItemId "Open..."    (Key 'O') Able   DoOpen
  47.                             ,    MenuItem SaveItemId "Save"       (Key 'S') Unable DoSave
  48.                             ,    MenuItem SvAsItemId "Save As..." NoKey     Able   DoSaveAs
  49.                             ,    MenuSeparator
  50.                             ,    MenuItem HelpItemId "Help..."    (Key 'H') Able   Help
  51.                             ,    MenuSeparator
  52.                             ,    MenuItem QuitItemId "Quit"       (Key 'Q') Able   DoQuit
  53.                             ]
  54.     machine                = PullDownMenu MachineMenuId "Machine" Able
  55.                             [    MenuItem StepItemId  "Step"      (Key 'T') Unable DoStep
  56.                             ,    MenuItem RunItemId   "Run"       (Key 'R') Unable DoRun
  57.                             ,    MenuItem HaltItemId  "Continue"  (Key '.') Unable DoContinue
  58.                             ,    MenuSeparator
  59.                             ,    SubMenuItem DelayItemId "Speed" Able [delay]
  60.                             ]
  61.     delay                = MenuRadioItems NormId
  62.                             [    MenuRadioItem VerSId "Very Slow" (Key '1') Able (SetDelay Speed1)
  63.                             ,    MenuRadioItem SlowId "Slow"      (Key '2') Able (SetDelay Speed2)
  64.                             ,    MenuRadioItem NormId "Normal"    (Key '3') Able (SetDelay Speed3)
  65.                             ,    MenuRadioItem FastId "Fast"      (Key '4') Able (SetDelay Speed4)
  66.                             ,    MenuRadioItem VerFId "Very Fast" (Key '5') Able (SetDelay Speed5)
  67.                             ]
  68.  
  69.     window                = WindowSystem [trswd, tapewd]
  70.     trswd                = ScrollWindow WindowID WdCorner "Turing Machine" Horbar Verbar
  71.                             WindowPSize WindowMin WindowInit UpdateWindow
  72.                             [    Mouse    Able EditTransitions
  73.                             ,    GoAway    DoQuit
  74.                             ]
  75.     tapewd                = ScrollWindow TapeWdID TWdCorner "Tape" Horbar Verbar
  76.                             TapeWdPSize TapeWdMin TapeWdInit UpdateTapeWd
  77.                             [    Mouse    Able EditTape
  78.                             ,    GoAway    DoQuit
  79.                             ]
  80.                                       
  81.     timer                = TimerSystem [Timer TimerID Unable Speed3 TimerStep]
  82.  
  83. NewTuring :: Files -> Tm
  84. NewTuring files
  85. =    {    tmstate    = {    turing        = {    transitions    = []
  86.                                   ,    tape        = {    content    = ""
  87.                                                     ,    head    = 0
  88.                                                     }
  89.                                   ,    state        = ""
  90.                                   }
  91.                   ,    transition    = 0
  92.                   ,    command        = None
  93.                   }
  94.     ,    name    = ""
  95.     ,    delay    = Speed3
  96.     ,    disk    = files
  97.     ,    saved    = True
  98.     }
  99.  
  100.  
  101. //    Open a new empty Turing machine.
  102. DoNew :: Tm (IOState Tm) -> (Tm,IOState Tm)
  103. DoNew tm=:{delay,disk,saved} io
  104. |    saved                = MakeNewTuring tm io
  105. #    (sure,tm,io)        = SaveBeforeClose "opening a new Turing machine" tm io
  106. |    sure                = MakeNewTuring tm io
  107. |    otherwise            = (tm,io)
  108.  
  109. MakeNewTuring :: Tm (IOState Tm) -> (Tm,IOState Tm)
  110. MakeNewTuring {delay,disk} io
  111. #    io    = DrawInWindow        TapeWdID [ShowTape inittape]                    io
  112.     io    = DrawInWindow        WindowID [ShowTransitions [] ""]                io
  113.     io    = ChangeWindowTitle    WindowID "Turing Machine"                        io
  114.     io    = DisableMenuItems    [SaveItemId,StepItemId,RunItemId,HaltItemId]    io
  115. =    ({    tmstate    = {    turing        = {    transitions    = []
  116.                                   ,    tape        = inittape
  117.                                   ,    state        = ""
  118.                                   }
  119.                   ,    transition    = 0
  120.                   ,    command        = None
  121.                   }
  122.      ,    name    = ""
  123.      ,    delay    = delay
  124.      ,    disk    = disk
  125.      ,    saved    = True
  126.      }
  127.      ,    io
  128.     )
  129. where
  130.     inittape    = {content="",head=0}
  131.  
  132. //    Save the Turing machine.
  133. DoSave :: Tm (IOState Tm) -> (Tm,IOState Tm)
  134. DoSave tm=:{tmstate={turing},name,disk} io
  135. #    (success,disk)    = WriteTuringToFile turing name disk
  136. |    success            = (    {tm & disk=disk,saved=True}
  137.                       ,    DisableMenuItems [SaveItemId] io
  138.                       )
  139. |    otherwise        = Alert "The Turing machine has not been saved." "The file could not be opened." {tm & disk=disk} io
  140.                       
  141.  
  142. DoSaveAs :: Tm (IOState Tm) -> (Tm,IOState Tm)
  143. DoSaveAs tm=:{name} io 
  144. #    (result,fname,tm=:{tmstate={turing},disk},io)
  145.                                 = SelectOutputFile "Save T.M. As:" (RemovePath name) tm io
  146. |    not result                    = (tm, io)
  147. |    RemovePath fname==HelpFile    = Alert "The Turing machine cannot be saved to" ("the help file \'"+++HelpFile+++"\'.") tm io
  148. #    (success,disk)                = WriteTuringToFile turing fname disk
  149. |    not success                    = Alert "The Turing machine has not been saved." "The file could not be opened." {tm & disk=disk} io
  150. #    io                            = ChangeWindowTitle WindowID (RemovePath fname) io
  151.     io                            = DisableMenuItems [SaveItemId] io
  152. |    otherwise                    = ({tm & name=fname,disk=disk,saved=True},io)
  153.  
  154. //    Load a Turing machine from a file.
  155. DoOpen :: Tm (IOState Tm) -> (Tm,IOState Tm)
  156. DoOpen tm=:{saved} io
  157. |    saved            = EvtOpenTuring tm  io
  158. #    (sure,tm,io)    = SaveBeforeClose "opening an other Turing machine" tm io
  159. |    sure            = EvtOpenTuring tm io
  160. |    otherwise        = (tm,io)
  161. where
  162.     EvtOpenTuring :: Tm (IOState Tm) -> (Tm,IOState Tm)
  163.     EvtOpenTuring  tm io 
  164.     #    (ok,filename,tm,io)    = SelectInputFile tm io
  165.     |    ok                    = OpenTuring filename tm io
  166.     |    otherwise            = (tm,io)
  167.     where
  168.         OpenTuring :: String Tm (IOState Tm) -> (Tm,IOState Tm)
  169.         OpenTuring name tm=:{delay,disk} io
  170.         |    fname==HelpFile    = Alert ("The help file"+++fstring) "cannot be opened as a T.M." tm io
  171.         #    (status,turing,disk)
  172.                             = ReadTuring name disk
  173.         |    status==0        = ({tm & tmstate={turing=turing,transition=0,command=None},name=name,disk=disk,saved=True},update)
  174.                             with
  175.                                 update    = ChangeIOState
  176.                                             [    EnableMenuItems        [RunItemId,StepItemId,HaltItemId]
  177.                                             ,    DrawInWindow        TapeWdID [ShowTape turing.tape]
  178.                                             ,    DrawInWindow        WindowID [ShowTransitions turing.transitions turing.state]
  179.                                             ,    ChangeWindowTitle    WindowID (RemovePath name)
  180.                                             ,    DisableMenuItems    [SaveItemId]
  181.                                             ]    io
  182.         |    status> 0        = Alert ("Parse error in line "+++toString status) ("of file"+++fstring+++".") {tm & disk=disk} io
  183.         |    status==(-1)    = Alert "Unexpected end of file" (fstring+++".") {tm & disk=disk} io
  184.         |    otherwise        = Alert ("The file"+++fstring) "could not be opened." {tm & disk=disk} io
  185.         where
  186.             fname            = RemovePath name
  187.             fstring            = " \'"+++fname+++"\'"
  188.  
  189.  
  190. //    The Help command.
  191. Help :: Tm (IOState Tm) -> (Tm,IOState Tm)
  192. Help tm=:{disk} io
  193. #    (disk,io)    = ShowHelp HelpFile disk io
  194. =    ({tm & disk=disk},io)
  195.  
  196.  
  197. //    Let the Turing machine do one step (transition).
  198. DoStep :: Tm (IOState Tm) -> (Tm,IOState Tm)
  199. DoStep tm=:{tmstate=tmstate=:{turing={tape={head},state},transition}} io
  200. |    state=="halt" || state=="error"
  201. =    (tm,io)
  202. #    tmstate    = Step tmstate
  203.     tm        = {tm & tmstate=tmstate}
  204.     (newtrn,newstate,newcom)
  205.             = (\{turing,transition,command}->(transition,turing.state,command)) tmstate
  206.     io        = DrawInWindow WindowID [ShowTransition transition newtrn,ShowNextState newstate] io
  207.     io        = DrawInWindow TapeWdID [ShowNewTape newcom head] io
  208.     io        = StepChangeMenus newstate io
  209. |    otherwise
  210. =    ({tm & tmstate=tmstate},io)
  211. where
  212.     StepChangeMenus :: String (IOState Tm) -> (IOState Tm)
  213.     StepChangeMenus state io
  214.     |    state<>"halt" && state<>"error"    = io
  215.     |    otherwise                        = DisableMenuItems [StepItemId,HaltItemId] io
  216.  
  217.  
  218. //    Let the T.M. run until the haltstate is reached.
  219. DoRun :: Tm (IOState Tm) -> (Tm,IOState Tm)
  220. DoRun tm=:{tmstate={turing}} io
  221. #    io    = DisableMouse                TapeWdID                io
  222.     io    = DisableMouse                WindowID                io
  223.     io    = EnableMenuItems             [HaltItemId]            io
  224.     io    = ChangeMenuItemTitles        [(HaltItemId,"Halt")]    io
  225.     io    = ChangeMenuItemFunctions    [(HaltItemId,DoHalt)]    io
  226.     io    = DisableMenuItems            [StepItemId, RunItemId]    io
  227.     io    = DisableMenus                [FileMenuId]            io
  228.     io    = DrawInWindow                TapeWdID [EraseError]    io
  229.     io    = EnableTimer                 TimerID                    io
  230. =    ({tm & tmstate={tm.tmstate & turing={turing & state="S"}}},io)
  231.  
  232.  
  233. //    Halt a running T.M.
  234. DoHalt :: Tm (IOState Tm) -> (Tm,IOState Tm)
  235. DoHalt tm io
  236. #    io    = EnableMouse                TapeWdID                    io
  237.     io    = EnableMouse                WindowID                    io
  238.     io    = ChangeMenuItemTitles        [(HaltItemId,"Continue")]    io
  239.     io    = ChangeMenuItemFunctions    [(HaltItemId,DoContinue)]    io
  240.     io    = EnableMenuItems            [StepItemId, RunItemId]        io
  241.     io    = EnableMenus                [FileMenuId]                io
  242.     io    = DisableTimer                TimerID                        io
  243. =    (tm,io)
  244.  
  245. //    Continue a halted T.M.
  246. DoContinue :: Tm (IOState Tm) -> (Tm,IOState Tm)
  247. DoContinue tm io
  248. #    io    = DisableMouse                TapeWdID                    io
  249.     io    = DisableMouse                WindowID                    io
  250.     io    = ChangeMenuItemTitles        [(HaltItemId,"Halt")]        io
  251.     io    = ChangeMenuItemFunctions    [(HaltItemId,DoHalt)]        io
  252.     io    = DisableMenuItems            [StepItemId, RunItemId]        io
  253.     io    = DisableMenus                 [FileMenuId]                io
  254.     io    = EnableTimer                TimerID                        io
  255. =    (tm,io)
  256.  
  257. //    Set the speed (delay) of a (possibly running) T.M.
  258. SetDelay :: Int Tm (IOState Tm) -> (Tm,IOState Tm)
  259. SetDelay delay tm io
  260. =    ({tm & delay=delay},SetTimerInterval TimerID delay io)
  261.  
  262.  
  263. //    Quit the program.
  264. DoQuit :: Tm (IOState Tm) -> (Tm,IOState Tm)
  265. DoQuit tm=:{saved} io
  266. |    saved            = (tm, QuitIO io)
  267. #    (sure,tm,io)    = SaveBeforeClose "quitting" tm io
  268. |    sure            = (tm, QuitIO io)
  269. |    otherwise        = (tm, io)
  270.  
  271.  
  272. //    When a mouseclick occurs the T.M. can be edited.
  273. EditTransitions :: MouseState Tm (IOState Tm) -> (Tm,IOState Tm)
  274. EditTransitions (mpos,ButtonDown,_) tm=:{tmstate={turing={transitions}}} io
  275. |    ontrans                        = AlterTransition transnr tm io
  276. |    onstate                        = AlterState tm io
  277. |    otherwise                    = (tm,io)
  278. where
  279.     (nr,ontrans,onstate)        = ClickedInWindow mpos
  280.     lasttrans                    = NrOfTransitions transitions
  281.     transnr                        = if (nr>lasttrans) lasttrans nr
  282. EditTransitions _ tm io            = (tm,io)
  283.  
  284. EditTape :: MouseState Tm (IOState Tm) -> (Tm,IOState Tm)
  285. EditTape (mpos,ButtonDown,CommandOnly) tm=:{tmstate={turing}} io
  286. |    not ontape                    = (tm,io)
  287. #    tape                        = MoveHead newpos turing.tape
  288.     (((left,_),(right,_)),io)    = WindowGetFrame TapeWdID io
  289.     io                            = DrawInWindow TapeWdID [ShowHeadMove {tape & head=oldpos} newpos left right] io
  290. |    otherwise                    = ({tm & tmstate={tm.tmstate & turing={turing & tape=tape}}},io)
  291. where
  292.     oldpos                        = turing.tape.head
  293.     (newpos,ontape)                = ClickedInTapeWd mpos
  294. EditTape (mpos,ButtonDown,_) tm=:{tmstate={turing}} io
  295. |    ontape                        = AlterCell (min nr (NrOfCells turing.tape.content)) tm io
  296. |    otherwise                    = (tm,io)
  297. where
  298.     (nr,ontape)                    = ClickedInTapeWd mpos
  299. EditTape _ tm io                = (tm,io)
  300.  
  301.  
  302. //    The window update and activate functions.
  303. UpdateWindow :: UpdateArea Tm -> (Tm, [DrawFunction])
  304. UpdateWindow update_area tm=:{tmstate={turing={transitions,state},transition}}
  305. =    (    tm
  306.     ,    [    SetTuringFont
  307.         ,    ShowTransitions transitions state
  308.         ,    ShowTransition  transition transition
  309.         ]
  310.     )
  311.  
  312. UpdateTapeWd :: UpdateArea Tm -> (Tm, [DrawFunction])
  313. UpdateTapeWd [((start,_),(end,_)):areas] tm=:{tmstate={turing={tape}}}
  314. #    (tm,rest)    = UpdateTapeWd areas tm
  315. =    (    tm
  316.     ,    [    SetTuringFont
  317.         ,    ShowTapePart tape start end
  318.         :    rest
  319.         ]
  320.     )
  321. UpdateTapeWd _ tm
  322. =    (tm,[])
  323.  
  324.  
  325. //    The step function for the Timer device (used by the Run command).
  326. TimerStep :: TimerState Tm (IOState Tm) -> (Tm,IOState Tm)
  327. TimerStep times tm=:{tmstate={turing={state}}} io
  328. |    state<>"halt" && state<>"error"
  329. =    DoStep tm io
  330. #    io    = DisableTimer                TimerID                        io
  331.     io    = EnableMouse                TapeWdID                    io
  332.     io    = EnableMouse                WindowID                    io
  333.     io    = ChangeMenuItemTitles        [(HaltItemId,"Continue")]    io
  334.     io    = ChangeMenuItemFunctions    [(HaltItemId,DoContinue)]    io
  335.     io    = DisableMenuItems            [HaltItemId]                io
  336.     io    = EnableMenuItems            [RunItemId]                    io
  337.     io    = EnableMenus                [FileMenuId]                io
  338. |    otherwise
  339. =    (tm,io)
  340.